home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / dbase / lib19.zip / FILES.PRG < prev    next >
Text File  |  1992-10-09  |  83KB  |  2,127 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: FILES.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are file processing routines. To see how to use this 
  6. *--             library file, see: README.TXT.
  7. *-------------------------------------------------------------------------------
  8.  
  9. PROCEDURE AllTags
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Susan Perschke (SPECDATA) and Michael Liczbanski (LMIKE)
  12. *-- Date........: 01/03/1992
  13. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  14. *--               so they can change the current tag ... This was gotten to me
  15. *--               by Steve (LTI), from "Data Based Advisor", December, 1991.
  16. *-- Written for.: dBASE IV, 1.1
  17. *-- Rev. History: 12/15/1991 - original procedure.
  18. *--               01/03/1992 - Ken Mayer -- added shadow ...
  19. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  20. *-- Called by...: Any
  21. *-- Usage.......: DO AllTags WITH nULRow, nULCol
  22. *-- Example.....: ON KEY LABEL F8 DO ALLTAGS WITH 02,60
  23. *-- Returns.....: None
  24. *-- Parameters..: nULRow -- Starting Row for Popup
  25. *--               nULCol -- Starting Column for Popup
  26. *-------------------------------------------------------------------------------
  27.  
  28.     parameters nULRow, nULCol
  29.     private nBar, cPrompt, nBRRow, nBRCol
  30.     
  31.     *-- Disable left/right arrow keys to prevent an accidental exit
  32.     on key label leftarrow  ?? chr(7)
  33.     on key label rightarrow ?? chr(7)
  34.     
  35.     *-- Save current screen
  36.     save screen to sTag
  37.     activate screen
  38.     
  39.     *-- define the popup
  40.     define popup pTag from nULRow, nULCol;
  41.        message " Press ENTER to select new index order...ESC to exit..."
  42.     nBar = 1                        && first bar
  43.     cPrompt    = "-No Index-"       &&  will always be this
  44.     
  45.     *-- loop to get the rest of 'em ...
  46.     do while "" <> cPrompt          && loop until no more tags
  47.         define bar nBar of pTag prompt (cPrompt)
  48.         cPrompt = tag(nBar)
  49.         nBar = nBar + 1
  50.     enddo
  51.     
  52.     on selection popup pTag deactivate popup
  53.     
  54.     *-- process shadow
  55.     nBRRow = nULRow+(nBar-1)+1 && bottom right for shadow (1 for t/b of pop)
  56.     nBRCol = nULCol+11         && bottom right for shadow (2 for sides,
  57.                                &&   +9 for tagnames)
  58.     do shadow with nULRow,nULCol,nBRRow,nBRCol
  59.     
  60.     *-- do it
  61.     activate popup pTag
  62.     
  63.     *-- Assign a null string to cPrompt if "No Index" selected
  64.     cPrompt = iif(bar() = 1, "",prompt())
  65.     
  66.     *-- Don't change index order if ESC pressed
  67.     if bar() <> 0
  68.        set order to (cPrompt)
  69.     endif
  70.     
  71.     *-- cleanup
  72.     release popup pTag
  73.     restore screen from sTag
  74.     release screen sTag
  75.     
  76.     *-- Enable left/right arrow keys
  77.     on key label leftarrow
  78.     on key label rightarrow
  79.  
  80. RETURN
  81. *-- EoP: AllTags
  82.  
  83. PROCEDURE MakeTagFl
  84. *-------------------------------------------------------------------------------
  85. *-- Programmer..: Bowen Moursund (BOWEN)
  86. *-- Date........: 04/15/1992
  87. *-- Notes.......: Build a .dbf file from scratch, without using CREATE FROM.
  88. *--               The file built has three fields, TAGS1, TAGS2 and TAGS3,
  89. *--               each character-type and 254 bytes wide.
  90. *-- Written for.: dBASE IV, 1.1
  91. *-- Rev. History: Broken out of other code and date-writing added
  92. *--               by Jay Parsons, 4/15/1992
  93. *--             : Originally from the program PRGCREAT.ZIP
  94. *-- Called by...: Any
  95. *-- Usage.......: do MakeTagFl WITH "<cFname>"
  96. *-- Example.....: do MakeTagFl WITH "Tags"
  97. *-- Returns.....: None
  98. *-- Parameters..: cFname, name of the .dbf to create
  99. *-- Side effects: Creates a .dbf and overwrites any existing one of same name
  100. *--             : Disables external setting of PRINTER
  101. *-------------------------------------------------------------------------------
  102.     parameters cFname
  103.     private cName
  104.     cName = cFname
  105.     if .not. "." $ cName
  106.        cName = cName + ".DBF"
  107.     endif
  108.     set printer to file ( cName )
  109.     set printer on
  110.     ??? "{3}"
  111.     ??? chr( year( date() - 1900 ) )
  112.     ??? chr( month( date() ) )
  113.     ??? chr( day( date() ) )
  114.     ??? "{0}{0}{0}{0}{129}{0}{251}{2}{0}{0}{0}{0}"
  115.     ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{201}{0}"
  116.     ??? "{84}{65}{71}{83}{49}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags1
  117.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  118.     ??? "{84}{65}{71}{83}{50}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags2
  119.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  120.     ??? "{84}{65}{71}{83}{51}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags3
  121.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  122.     ??? "{13}{26}"
  123.     set printer off
  124.     set printer to
  125.  
  126. RETURN
  127. *-- EoP: MakeTagFl
  128.  
  129. PROCEDURE RedoTags
  130. *-------------------------------------------------------------------------------
  131. *-- Programmer..: David Love (DAVIDLOVE on the Borland Support Bulletin Board)
  132. *-- Date........: 04/18/1992
  133. *-- Notes.......: This routine is a "generic" MDX cleanup routine. It is useful
  134. *--               for handling "bloated" MDX files -- ones that have been around
  135. *--               awhile (they tend to be larger than necessary). This routine
  136. *--               will store the tag keys in an array, delete the tags, and then
  137. *--               rebuild the MDX file from scratch, keeping all tag names and
  138. *--               keys, and the MDX SHOULD be smaller.
  139. *--             : Will act on the dbf's production mdx (ie. same name as dbf)
  140. *-- Written for.: dBASE IV, 1.5
  141. *-- Rev. History: 01/20/1992 - original function for dBASE IV Ver. 1.1.
  142. *--               04/18/1992 - David Love - adapted for use with beta version
  143. *--               of dBASE IV, version 1.5.
  144. *--               (TAGCOUNT(), FOR(), DESCENDING(), UNIQUE() are 1.5 functions)
  145. *-- Calls.......: None
  146. *-- Called by...: Any
  147. *-- Usage.......: do RedoTags with "<cDBF>"
  148. *-- Example.....: do RedoTags with "Referral"
  149. *-- Returns.....: None
  150. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  151. *-------------------------------------------------------------------------------
  152.  
  153.     parameter cDBF
  154.     
  155.     use (cDBF) excl
  156.     
  157.     *-- First, figure out how many tags exist
  158.  
  159.     private nMaxTags
  160.     nMaxTags = tagcount( cDBF,1 )
  161.     
  162.     *-- only perform routine if an index tag exists
  163.     if nMaxTags > 0
  164.       private nTags, mkey, mtag
  165.     
  166.       *-- store the keys and tags to an array
  167.       declare aTags[nMaxTags,5]
  168.        nTags = 1
  169.       do while nTags <= nMaxTags
  170.         store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  171.         store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  172.         store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  173.         store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  174.         store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  175.         nTags = nTags + 1
  176.       enddo
  177.     
  178.        *-- now, delete the tags   
  179.        do while "" # tag( (cDBF),1)
  180.          delete tag tag( (cDBF),1)
  181.        enddo
  182.       
  183.        *-- rebuild the MDX, tag by tag ...
  184.        nTags = 1
  185.       do while nTags <= nMaxTags
  186.         mkey = aTags[nTags,1]+iif(""#aTags[nTags,3]," for "+aTags[nTags,3],"") ;
  187.           + iif(aTags[nTags,4]," DESCENDING","") ;
  188.           + iif(aTags[nTags,5]," UNIQUE","")
  189.          mtag = aTags[nTags,2]
  190.         index on &mkey. tag &mtag.
  191.          nTags = nTags + 1
  192.       enddo
  193.     
  194.        *-- release the array ...
  195.       release aTags
  196.     
  197.     endif  && check for tags ...
  198.     use    && close database
  199.     
  200. RETURN
  201. *-- EoP: RedoTags
  202.  
  203. PROCEDURE AutoRedo
  204. *------------------------------------------------------------------------------
  205. *-- Programmer..: Douglas P. Saine (XRED)
  206. *-- Date........: 03/06/1992
  207. *-- Notes.......: Displays a popup to choose a DBF from the current directory
  208. *--               to re-build its MDX file
  209. *-- Written for.: dBASE IV, 1.1
  210. *-- Rev. History: 03/04/1992 - original procedure.
  211. *--               03/06/1992 -- Ken Mayer (KENMAYER) added color parameter,
  212. *--                shadow to popup, and erase DBFS.DBF datafile at end.
  213. *-- Calls.......: LISTDBFS             Procedure in FILES.PRG
  214. *--               REDOTAGS             Procedure in FILES.PRG
  215. *--               CENTER               Procedure in PROC.PRG
  216. *--               YESNO2()             Function in PROC.PRG
  217. *--               SHADOW               Procedure in PROC.PRG       
  218. *--               EXTRCLR()            Function in PROC.PRG
  219. *-- Called by...: Any
  220. *-- Usage.......: do AutoRedo with nXTL,nYTL,nXBR,nYBR,cColor
  221. *-- Example.....: do AutoRedo with 5,34,15,47,"rg+/gb,w+/n,rg+/gb"
  222. *-- Returns.....: None
  223. *-- Parameters..: None
  224. *------------------------------------------------------------------------------
  225.  
  226.     parameters nXTL, nYTL, nXBR, nYBR, cColor
  227.     
  228.     *-- Save Environment
  229.     cTalk = set("talk")
  230.     cStat = set("status")
  231.     cCloc = set("clock")
  232.     cScor = set("scoreboard")
  233.     cSafe = set("safety")
  234.     
  235.     *-- Set Environment
  236.     set stat off
  237.     set talk off
  238.     set cloc off
  239.     set scor off
  240.     set safe off
  241.     
  242.     *-- Full Screen Window for screen restoration when finished
  243.     define window wCoverScr from 0,0 to 23,79 none
  244.     activate window wCoverScr
  245.     clear
  246.     
  247.     *-- Make a Data File of the Current Directory
  248.     do center with 10,80,extrclr('&cColor'),;
  249.             '... Making Data File from Current Directory ...'
  250.     do ListDBFs
  251.     
  252.     use DBFS
  253.     index on DBFS->DBF tag IORDER
  254.     
  255.     *-- Define and access the popup of DataFiles
  256.     activate screen
  257.     define popup uDbfList from nXTL,nYTL to nXBR,nYBR prompt field DBFS->DBF
  258.     on selection popup uDbfList deactivate popup
  259.     
  260.     *-- Execute loop for multiple re-indexes
  261.     clear
  262.     lLoop = .t.
  263.     do while lLoop
  264.         do shadow with nXTL,nYTL,nXBR,nYBR
  265.        activate popup uDbfList
  266.         clear  && get rid of shadow
  267.         
  268.        *--  Record the prompt() and remove '.dbf' so it works with Redotag
  269.        cDataFile = substr(prompt(),1,len(trim(prompt()))-4)
  270.     
  271.        *-- Verify the MDX exists
  272.        if file(cDataFile+'.mdx')
  273.           do redotags with cDataFile
  274.        else
  275.           do center with 10,80,extrclr("&cColor"),;
  276.             '... Production MDX file not found for file '+cDataFile
  277.           n = inkey(0)
  278.           clear
  279.        endif
  280.     
  281.        *-- Determine if the user wants to re-build another
  282.        if YesNo2(.t.,"CC","",;
  283.           "Do you wish to reindex another file?","","&cColor")
  284.           use DBFS order IORDER
  285.        else
  286.           lLoop = .f.
  287.        endif
  288.     
  289.     enddo
  290.     
  291.     *-- Restore environment
  292.     use DBFS
  293.     delete tag IORDER
  294.     use
  295.     erase DBFS.DBF
  296.     release popup uDbfList
  297.     deactivate window wCoverScr
  298.     release window wCoverScr
  299.     set stat &cStat
  300.     set talk &cTalk
  301.     set cloc &cCloc
  302.     set scor &cScor
  303.     set safe &cSafe
  304.     
  305. RETURN
  306. *-- EoP:  AutoRedo
  307.  
  308. PROCEDURE PrntTags
  309. *-------------------------------------------------------------------------------
  310. *-- Programmer..: David Love (DAVIDLOVE)
  311. *-- Date........: 04/18/1992
  312. *-- Notes.......: This routine is a "quick and not-so-dirty" method of printing
  313. *--               the tag and key expressions for a dbf's production mdx file.
  314. *--               It obviates the need for DISP/LIST STAT TO PRINT (or DISP STAT
  315. *--               followed by SHIFT+PrtScr).
  316. *--               This code is modified from the procedure RedoTags.prg,
  317. *--               previously posted on the BORBBS.
  318. *--             : The proc will print the full key expression, including
  319. *--               FOR/DESCENDING/UNIQUE options, if present.
  320. *-- Written for.: dBASE IV, 1.1
  321. *-- Rev. History: 01/31/1992 - original procedure written for dBASE IV, Ver. 1.1
  322. *--               04/18/1992 - David Love - revised for version 1.5
  323. *-- Calls.......: None
  324. *-- Called by...: Any
  325. *-- Usage.......: do PrntTags with "<cDBF>"
  326. *-- Example.....: do PrntTags with "Referral"
  327. *-- Returns.....: None
  328. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  329. *-------------------------------------------------------------------------------
  330.  
  331.     parameter cDBF
  332.     
  333.     use (cDBF)
  334.     
  335.     *-- First, figure out how many tags exist
  336.  
  337.     private nMaxTags
  338.     nMaxTags = tagcount( cDBF,1 )
  339.     
  340.     *-- only perform routine if an index tag exists
  341.     if nMaxTags > 0
  342.       private nTags, mkey, mtag
  343.     
  344.       *-- store the keys and tags to an array
  345.       declare aTags[nMaxTags,5]
  346.        nTags = 1
  347.       do while nTags <= nMaxTags
  348.         store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  349.         store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  350.         store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  351.         store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  352.         store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  353.          nTags = nTags + 1
  354.       enddo
  355.     
  356.       *-- print each tag with it's key expression
  357.       private cTalk
  358.       cTalk = set("TALK")
  359.       set talk off
  360.       set printer on
  361.       ?? "DATABASE: "+cDBF AT 0
  362.       ?
  363.       ?? "TAG" at 0
  364.       ?? "KEY EXPRESSION" AT 12
  365.       ?
  366.       nTags = 1
  367.       do while nTags <= nMaxTags
  368.         ?? aTags[nTags,2] AT 0
  369.         ?? aTags[nTags,1] + ;
  370.           iif(""#aTags[nTags,3]," FOR "+aTags[nTags,3],"") + ;
  371.           iif(aTags[nTags,4]," DESCENDING","") + ;
  372.           iif(aTags[nTags,5]," UNIQUE","") AT 12
  373.         ?
  374.         nTags = nTags + 1
  375.       enddo
  376.       ?
  377.       set printer off
  378.       set talk &cTalk.
  379.  
  380.       *-- release the array ...
  381.       release aTags
  382.     
  383.     endif  && check for tags ...
  384.     use    && close database
  385.     
  386. RETURN
  387. *-- EoP: PrntTags
  388.  
  389. PROCEDURE ListDBFs
  390. *-------------------------------------------------------------------------------
  391. *-- Programmer..: David Love (DAVIDLOVE)
  392. *-- Date........: 01/31/1992
  393. *-- Notes.......: This procedure will create a list of the database (.dbf) files
  394. *--               in the current directory.  It will create a database file
  395. *--               named Dbfs.dbf which exists of one 12-character field--Dbf.
  396. *--               It will also create a text file, Dbfs.txt, through the
  397. *--               LIST FILES to FILE command.  Then it will append records
  398. *--               to the Dbfs.dbf file and erase the Dbfs.txt file.
  399. *--             : This Dbfs.dbf file can be SCANned, or used in a POPUP PROMPT
  400. *--               FIELD command, or in any way that you can imagine.
  401. *--             : The file 'Dbfs.dbf' will not be included in the Dbfs.dbf file.
  402. *-- WARNING===> : If your application includes a file with the name of
  403. *--               'Dbfs.dbf', it will be overwritten with the file created
  404. *--                by this procedure.
  405. *-- Written for.: dBASE IV, 1.1
  406. *-- Rev. History: None
  407. *-- Calls.......: None
  408. *-- Called by...: Any
  409. *-- Usage.......: do ListDBFs
  410. *-- Example.....: do ListDBFs
  411. *-- Returns.....: None
  412. *-- Parameters..: None
  413. *-------------------------------------------------------------------------------
  414.  
  415.    private cConsole
  416.    *-- Write the directory of dbf files to a text file (Dbfs.txt)
  417.    *-- First, erase the file if it exists
  418.    if file("Dbfs.txt")
  419.      erase dbfs.txt
  420.    endif
  421.  
  422.    *-- And, erase the dbfs.dbf file if it exists (so won't be included
  423.    *-- in the list)
  424.    if file("Dbfs.dbf")
  425.      erase Dbfs.dbf
  426.    endif
  427.  
  428.    *-- Now, write the dbfs.txt file
  429.    cConsole = set("CONSOLE")
  430.    set console off
  431.    list files to file dbfs.txt
  432.    set console &cConsole.
  433.  
  434.    *-- Then, create the file DBFS.DBF
  435.     *-- Acknowledgement..: Bowen Moursund for the code that creates Dbfs.dbf
  436.     *--                    (Download PRGCREAT.ZIP from BORBBS for more info.)
  437.    set printer to file DBFS.DBF
  438.    set printer on
  439.    ??? "{3}{92}{2}{1}{0}{0}{0}{0}{65}{0}{13}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  440.    "{0}{0}{0}{0}{0}{0}{0}{0}{89}{0}{68}{66}{70}{0}{0}{0}{0}{0}{0}{0}{0}{67}{3}"+;
  441.    "{0}{44}{85}{12}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{13}{26}"
  442.    set printer to
  443.    set printer off
  444.  
  445.    *-- Now, append dbfs.txt to dbfs.dbf if the record is a dbf listing.
  446.    use Dbfs
  447.    append from Dbfs.txt for ".DBF" $ Dbf type sdf
  448.  
  449.    use    && can remove this command if you want
  450.  
  451.    erase Dbfs.txt            && don't need it anymore
  452.  
  453. RETURN
  454. *--EOP: ListDBFs
  455.  
  456. FUNCTION Recompile
  457. *-------------------------------------------------------------------------------
  458. *-- Programmer..: Jay Parsons (Jparsons)
  459. *--             : Adapted from Compall.prg and Compall2.prg, by James Thomas.
  460. *-- Date........: 04/16/1992
  461. *-- Notes.......: Recompiles all dBASE source-code files.  Takes three
  462. *--             : optional parameters:
  463. *--             :    Directory to recompile.  Default is current directory.
  464. *--             :    Skeleton to recompile.  Default is all of .PRG, .LBG,
  465. *--             :       .FRG, .PRS, .FMT, .QBE and .UPD files.  If a skeleton
  466. *--             :       is provided that matches files that are not dBASE
  467. *--             :       source-code files, compiler errors will occur and,
  468. *--             :       in the absence of external error handling, see below,
  469. *--             :       suspend processing.
  470. *--             :    "Runtime" or any characters starting with "R" or "r" to
  471. *--             :       direct the compilation be with the "RUNTIME" option.
  472. *--             : Does not recompile a file if a file of the same root name,
  473. *--             : an .??O extension and a later timestamp resides in the
  474. *--             : directory.
  475. *--             : Renames compilations of FMT, FRG, LBG and QBO files to ??O.
  476. *--             : Returns .T. if successful, or .F.
  477. *--             :
  478. *--             : Listing of compilation errors requires SET ALTERNATE TO,
  479. *--             : and trapping such errors as passing the name of a file
  480. *--             : that does not contain dBASE source code to the COMPILE
  481. *--             : command requires an ON ERROR trap.  These are omitted here
  482. *--             : due to lack of ways to prevent the function from changing
  483. *--             : these settings externally.  Lines needed to have any
  484. *--             : compilation errors print to the alternate file are included
  485. *--             : as comments.
  486. *--             :
  487. *-- Written for.: dBASE IV Version 1.5.
  488. *--             : Adaptation to a prior release may require changing the
  489. *--             : way parameters are handled, and also rewriting the lines
  490. *--             : that use fdate() and ftime() to read timestamps.
  491. *-- Rev. History: 04/07/1992 - original function.
  492. *--             : 04/13/1992 - additional environment settings.
  493. *--             : 04/16/1992 - aliases added thanks to BOWEN.
  494. *--             : 06-10-1992 - a few minor bug fixes
  495. *-- Calls       : Makestru()            FUNCTION in FILES.PRG
  496. *-- Called by...: Any
  497. *-- Usage.......: Recompile ( [<cDir>] [,<cSkel> [,"R"]] )
  498. *-- Example.....: ? Recompile ( "\dBASE\Myprogs", "*.??G" )
  499. *-- Parameters..: cDir, a DOS directory name ( and path if needed )
  500. *--             : cSkel, skeleton using wildcards for files to compile
  501. *--             : cRun, "R" or "r" if compilation is for Runtime
  502. *-- Side effects: Creates compiled .??O files, overwriting any of the same
  503. *--             : root names that may exist.
  504. *-------------------------------------------------------------------------------
  505.  
  506.    parameters cDirectry, cSkeleton, cRun
  507.    private cCons, cAlias, cAlt, cDir, cSafety, cTempfile,;
  508.        cSrcfile, cObjfile, cString1, cString2, cRunopt
  509.  
  510.    * preserve environment
  511.    cCons = set( "CONSOLE" )
  512.    SET CONSOLE OFF
  513.    cAlias = alias()
  514.    cAlt = set( "ALTERNATE" )
  515.    SET ALTERNATE OFF
  516.    cDir = set( "DIRECTORY" )
  517.    IF type( "cDirectry" ) = "C" .AND. "" # cDirectry
  518.       SET DIRECTORY TO &cDirectry
  519.    ENDIF
  520.    cSafety = set( "SAFETY" )
  521.    SET SAFETY OFF
  522.    SELECT select()
  523.  
  524.    * make temporary structure file and fill in the DOS DIR listing structure
  525.    cTempfile = Makestru()
  526.    USE ( cTempfile ) ALIAS cTempfile
  527.    APPEND BLANK
  528.    REPLACE FIELD_NAME WITH "FILENAME", FIELD_TYPE WITH "C", FIELD_LEN WITH 9, ;
  529.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  530.    APPEND BLANK
  531.    REPLACE FIELD_NAME WITH "EXT", FIELD_TYPE WITH "C", FIELD_LEN WITH 4, ;
  532.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  533.    APPEND BLANK
  534.    REPLACE FIELD_NAME WITH "FLENGTH", FIELD_TYPE WITH "C", FIELD_LEN WITH 10, ;
  535.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  536.    APPEND BLANK
  537.    REPLACE FIELD_NAME WITH "TIMESTAMP", FIELD_TYPE WITH "C", FIELD_LEN WITH 16, ;
  538.            FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  539.  
  540.    * make .dbf for source file names, reset and return if error occurs
  541.    cSrcfile = cTempfile
  542.    DO WHILE file ( cSrcfile + ".DBF" )
  543.       cSrcfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  544.    ENDDO
  545.    CREATE ( cSrcfile ) FROM  ( cTempfile )
  546.    USE ( cSrcfile ) alias cSrcfile
  547.  
  548.    IF "" = alias()
  549.      ERASE ( cTempfile +".DBF" )
  550.      SET DIRECTORY TO &cDir
  551.      SET ALTERNATE &cAlt
  552.      IF "" # cAlias
  553.         SELECT ( cAlias )
  554.      ENDIF
  555.      SET CONSOLE &cCons
  556.      RETURN .F.
  557.    ENDIF
  558.  
  559.    * and for object file names
  560.    SELECT select()
  561.    USE ( cTempfile ) ALIAS cTempfile
  562.    GO 1
  563.    REPLACE FIELD_IDX WITH "Y"
  564.    cObjfile = cSrcfile
  565.    DO WHILE file ( cObjfile + ".DBF"  )
  566.       cObjfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  567.    ENDDO
  568.    CREATE ( cObjfile ) FROM (cTempfile)
  569.    use ( cObjfile ) alias cObjfile order filename
  570.    IF "" = alias()
  571.       ERASE ( cTempfile + ".DBF" )
  572.       SELECT cSrcfile
  573.       USE
  574.       ERASE ( cSrcfile + ".DBF" )
  575.       SET DIRECTORY TO &cDir
  576.       SET ALTERNATE &cAlt
  577.       IF "" # cAlias
  578.          SELECT  ( cAlias )
  579.       ENDIF
  580.       SET CONSOLE &cCons
  581.       RETURN .F.
  582.    ENDIF
  583.  
  584.    * reuse name of cTempfile as SDF; DIR names of source files to it and append
  585.    cString1 = cTempfile + ".DBF"
  586.  
  587.    RUN dir *.* > &cString1
  588.    SELECT  cSrcfile
  589.    APPEND FROM ( cString1 ) TYPE SDF
  590.  
  591.    * delete directory entries not for source files of desired name or type
  592.    IF type("cSkeleton") = "C" .AND. "" # cSkeleton
  593.       DELETE ALL FOR .NOT. like( upper( cSkeleton ), trim( Filename ) +"." ;
  594.             + trim( Ext ) )
  595.    ELSE
  596.       DELETE ALL FOR .NOT. Ext $ "PRG LBG FRG PRS FMT QBE UPD "
  597.    ENDIF
  598.    PACK
  599.  
  600.    * reuse again for .??O files
  601.    RUN dir *.??o > &cString1
  602.    SELECT cObjfile
  603.    APPEND FROM ( cString1 ) TYPE SDF
  604.    DELETE ALL FOR left( Filename, 1 ) = " " .OR. right( Ext, 2 ) # "O "
  605.    PACK
  606.    ERASE ( cString1 )
  607.  
  608.    * assemble Runtime option
  609.    cRunopt = iif( type( "cRun" ) = "C" .AND. "" # cRun ;
  610.            .AND. left( cRun, 1 ) $ "Rr", " RUNTIME", "" )
  611.  
  612.    * now compile all the files that need it
  613.    SELECT cSrcfile
  614.    SCAN
  615.       cString1 = trim( Filename ) + "." + trim( Ext )
  616.       *   Is there an object file of this name?
  617.       IF Seek( Filename, "cObjfile" )
  618.          cString2 = trim( cObjfile->Filename ) + "." + trim( cObjfile->Ext )
  619.          cString2 = dtos( fdate( cString2 ) ) + ftime( cString2 )
  620.          *   then check timestamps and skip it if already compiled
  621.          IF dtos( fdate( cString1 ) ) + ftime( cString1 ) < cString2
  622.             LOOP
  623.          ENDIF
  624.       ENDIF
  625.       *   compile it otherwise, listing errors if enabled
  626.       cString2 = cString1 + cRunopt
  627.       * SET ALTERNATE ON
  628.       * ? "Compiling " + cString2
  629.       COMPILE &cString2
  630.       * ?
  631.       * SET ALTERNATE OFF
  632.       *   and rename object files that should not be .DBOs
  633.       IF Ext $ "FMT FRG LBG QBE "
  634.          cString2 = stuff( cString1, len( cString1 ), 1, "O" )
  635.          IF file( cString2 )
  636.             ERASE ( cString2 )
  637.          ENDIF
  638.          cString1 = trim( Filename ) + ".DBO"
  639.          RENAME ( cString1 ) TO ( cString2 )
  640.       ENDIF
  641.    ENDSCAN
  642.  
  643.    *  Clean up
  644.    USE
  645.    ERASE ( cSrcfile + ".DBF" )
  646.    SELECT cObjfile
  647.    USE
  648.    ERASE ( cObjfile + ".DBF" )
  649.    ERASE ( cObjfile + ".MDX" )
  650.    SET SAFETY &cSafety
  651.    SET DIRECTORY TO &cDir
  652.    SET ALTERNATE &cAlt
  653.    IF "" # cAlias
  654.      SELECT ( cAlias )
  655.    ENDIF
  656.    SET CONSOLE &cCons
  657.  
  658. RETURN .T.
  659. *-- Eof() Recompile
  660.  
  661. PROCEDURE Makedbf
  662. *-------------------------------------------------------------------------------
  663. *-- Programmer..: Jay Parsons (Jparsons).
  664. *-- Date........: 04/26/1992
  665. *-- Notes.......: Makes an empty dBASE .dbf file
  666. *-- Written for.: dBASE IV, 1.1, 1.5
  667. *-- Rev. History: None
  668. *-- Calls       : Tempname()          function in FILES.PRG
  669. *-- Called by...: Any
  670. *-- Usage.......: DO MakeDbf WITH <cFilename>, <cStrufile>, <cArray>
  671. *-- Example.....: DO MakeDbf WITH Customers, cCustfields
  672. *-- Parameters..: cFilename - filename ( without extension ) of the .dbf to be
  673. *--               created.
  674. *--               cStrufile - name ( without extension ) of a STRUC EXTE .dbf
  675. *--               cArray - name of the array holding field information for the
  676. *--               .dbf.  The array must be dimensioned [ F, 5 ] where F is the
  677. *--               number of fields.  Each row must hold data for one field:
  678. *--                     [ F, 1 ]  field name, character
  679. *--                     [ F, 2 ]  field type, character from set "CDFLMN"
  680. *--                     [ F, 3 ]  field length, numeric.  If field type is
  681. *--                                 D, L, or M, will be ignored
  682. *--                     [ F, 4 ]  field decimals, numeric. optional if 0.
  683. *--                     [ F, 5 ]  field is mdx tag, char $ "YN", optional if N
  684. *-------------------------------------------------------------------------------
  685.   parameters cFname, cSname, aAname
  686.   private nX,cF1,cF2,cF3,cF4,cF5,cStrufile,cFtype
  687.   cF1 = aAname + "[nX,1]"
  688.   cF2 = aAname + "[nX,2]"
  689.   cF3 = aAname + "[nX,3]"
  690.   cF4 = aAname + "[nX,4]"
  691.   cF5 = aAname + "[nX,5]"
  692.   select select()
  693.   use ( cSname ) ALIAS cSname
  694.   zap
  695.   nX = 1
  696.   do while type( cF1 ) # "U"
  697.     cFtype = &cF2
  698.     append blank
  699.     replace Field_name with &cF1, Field_type with cFtype
  700.     do case
  701.       case cFtype = "D"
  702.         replace Field_len with 8
  703.       case cFtype = "M"
  704.         replace Field_len with 10
  705.       case cFtype = "L"
  706.         replace Field_len with 1
  707.       otherwise
  708.         replace Field_len with &cF3
  709.     endcase
  710.     if type( cF4 ) = "N" .and. cFtype $ "FN"
  711.         replace Field_dec with &cF4
  712.     else
  713.     replace Field_dec with 0
  714.     endif
  715.     if type( cF5 ) # "U" .and. cFtype $ "CDFN" .and. &cF5 = "Y"
  716.       replace Field_idx with "Y"
  717.     else
  718.       replace Field_idx with "N"
  719.     endif
  720.     nX = nX + 1
  721.   enddo
  722.   use
  723.   create ( cFname ) FROM ( cSname )
  724.  
  725. RETURN
  726. *-- EoP: Makedbf
  727.  
  728. PROCEDURE MakeDBF2
  729. *-------------------------------------------------------------------------------
  730. *-- Programmer..: Bowen Moursund
  731. *-- Date........: 05-27-1992
  732. *-- Notes.......: Creates an empty DBF file of the structure specified in
  733. *--               the array aMakeDBF[], which must be declared and initialized
  734. *--               with the proper values before calling this procedure.
  735. *--               The array must be declared as aMakeDBF[n,5], where n is
  736. *--               the number of fields in the DBF to be created. The columns
  737. *--               of the array correspond to the fields of a structure extended
  738. *--               file, and must be initialized to the appropriate values,
  739. *--               before calling this procedure, one row for each field.
  740. *--
  741. *--               Structure of a structure extended file:
  742. *--               Field    Type  Len  Dec
  743. *--               -----------------------
  744. *--               FIELD_NAME  C   10    0
  745. *--               FIELD_TYPE  C    1    0
  746. *--               FIELD_LEN   N    3    0
  747. *--               FIELD_DEC   N    3    0
  748. *--               FIELD_IDX   C    1    0
  749. *--
  750. *--               aMakeDBF[n,1] = Field name: 10 or less characters
  751. *--               aMakeDBF[n,2] = Field type: 1 character
  752. *--                               "C" = character
  753. *--                               "N" = numeric
  754. *--                               "F" = float
  755. *--                               "D" = date
  756. *--                               "L" = logical
  757. *--                               "M" = memo
  758. *--               aMakeDBF[n,3] = Field length: numeric
  759. *--                               "C" = 1 - 254
  760. *--                               "N","F" = use dBASE guidelines
  761. *--                               "D" = 8
  762. *--                               "L" = 1
  763. *--                               "M" = 10
  764. *--               aMakeDBF[n,4] = Decimal places: numeric
  765. *--                               0 for non numeric fields
  766. *--               aMakeDBF[n,5] = MDX flag: 1 char, "Y" or "N"
  767. *--
  768. *-- Written for.: dBASE IV, 1.5
  769. *-- Rev. History: None
  770. *-- Calls.......: None
  771. *-- Called by...: Any
  772. *-- Usage.......: do MakeDBF with <cDBFpath>,<cStruPath>
  773. *-- Example.....: cStruPath = MakeStru2(.f.)
  774. *--               declare aMakeDBF[1,5]
  775. *--               aMakeDBF[1,1] = "FIELD1"
  776. *--               aMakeDBF[1,2] = "C"
  777. *--               aMakeDBF[1,3] = 20
  778. *--               aMakeDBF[1,4] = 0
  779. *--               aMakeDBF[1,5] = "N"
  780. *--               do MakeDBF2 with "foo", cStruPath
  781. *--               erase (cStruPath+".dbf")
  782. *--               release aMakeDBF
  783. *-- Returns.....: none
  784. *-- Parameters..: cDBFpath = the [path]filename of the DBF to be created.
  785. *--               cStruPath = the [path]filename of an empty structure extended
  786. *--                           file.
  787. *-------------------------------------------------------------------------------
  788.  
  789.    parameters cDBFpath,cStruPath
  790.    if pcount() = 2  && we need 2 parms
  791.       private all except aMakeDB*
  792.       if type("aMakeDBF[1,1]") = "C"  && check array validity
  793.          cAlias = alias()
  794.          select select()
  795.          use (cStruPath)
  796.          append from array aMakeDBF
  797.          use
  798.          create (cDBFpath) from (cStruPath)
  799.          use
  800.          if "" # cAlias
  801.             select (cAlias)
  802.          endif
  803.       endif
  804.    endif
  805.  
  806. RETURN
  807. *-- EoP: MakeDBF2
  808.  
  809. FUNCTION Makestru
  810. *-------------------------------------------------------------------------------
  811. *-- Programmer..: Martin Leon (Hman), formerly sysop of A-T BBS
  812. *--             : Revised by Jay Parsons, (Jparsons).
  813. *-- Date........: 04/24/1992
  814. *-- Notes.......: Makes an empty dBASE STRUCTURE EXTENDED file and returns
  815. *--             : its root name
  816. *-- Written for.: dBASE IV v1.5
  817. *-- Rev. History: 06/12/1991 - original function.
  818. *--             : Changed to take no parameter, return filename, 4-7-1992.
  819. *--             : Code added to preserve catalog status and name, 4-10-1992.
  820. *--             : Use of Tempname() added 4-24-92.
  821. *--             : set("safety") check, minor mods, 05-28-1992, Bowen Moursund
  822. *-- Calls       : Tempname()          Function in FILES.PRG
  823. *-- Called by...: Any
  824. *-- Usage.......: Makestru()
  825. *-- Example.....: Tempfile = Makestru()
  826. *-- Returns.....: Name of file created
  827. *-- Parameters..: None
  828. *-------------------------------------------------------------------------------
  829.  
  830.    private all
  831.    lTitleOn = ( set("TITLE") = "ON" )
  832.    lSafeOn = ( set("SAFETY") = "ON" )
  833.    lCatOff = ( set("CATALOG") = "OFF" )
  834.    cAlias = alias()
  835.    cTmpCat = TempName("cat") + ".CAT"
  836.    set title off
  837.    set safety off
  838.    cCatalog = catalog()
  839.    set catalog to (cTmpCat)
  840.    set catalog to &cCatalog.
  841.    cStruName = TempName("dbf")
  842.    select select()
  843.    use (cTmpCat) nosave
  844.    copy to (cStruName) structure extended
  845.    use (cStruName) exclusive
  846.    zap
  847.    use
  848.    if lTitleOn
  849.       set title on
  850.    endif
  851.    if lSafeOn
  852.       set safety on
  853.    endif
  854.    if lCatOff
  855.       set catalog off
  856.    endif
  857.    if "" # cAlias
  858.       select (cAlias)
  859.    endif
  860.     
  861. RETURN cStruname
  862. *-- Eof: Makestru()
  863.  
  864. FUNCTION MakeStru2
  865. *-------------------------------------------------------------------------------
  866. *-- Programmer..: Bowen Moursund (BOWEN)
  867. *-- Date........: 05-27-1992
  868. *-- Notes.......: Create an empty STRUCTURE EXTENDED file, using DBASE print
  869. *--               redirection. If specified, the file will be created in the
  870. *--               subdirectory pointed to by the DOS environment variable
  871. *--               DBTMP, if it is set, otherwise in the current subdirectory.
  872. *--
  873. *--               Structure of a STRUCTURE EXTENDED file:
  874. *--               Field    Type  Len  Dec
  875. *--               -----------------------
  876. *--               FIELD_NAME  C   10    0
  877. *--               FIELD_TYPE  C    1    0
  878. *--               FIELD_LEN   N    3    0
  879. *--               FIELD_DEC   N    3    0
  880. *--               FIELD_IDX   C    1    0
  881. *--
  882. *-- Written for.: dBASE IV v1.1
  883. *-- Rev. History: None
  884. *-- Calls.......: TEMPNAME
  885. *-- Called by...: Any, except when printing
  886. *-- Usage.......: MakeStru(<lDBTMP>)
  887. *-- Example.....: cStruPath = MakeStru2(.T.)
  888. *-- Returns.....: The name, no extension, of the file created.
  889. *-- Parameters..: lDBTMP = create the file in the DBTMP subdirectory, or not.
  890. *-- Side Effects: WARNING: Do not call when printing.
  891. *-------------------------------------------------------------------------------
  892.  
  893.    parameter lDBTMP
  894.    private all
  895.    cDBTMP = ""  && TempName() will assign this, if lDBTMP
  896.    if lDBTMP
  897.       cFname = TempName( "dbf", .t. )
  898.    else
  899.       cFname = TempName( "dbf", .f. )
  900.    endif
  901.    cPath = iif( "" # cDBTMP, cDBTMP, set("DIRECTORY") ) + "\" + cFname + ".DBF"
  902.    dDate = date()
  903.    set printer to file (cPath)
  904.    set printer on
  905.    * Thanks to JPARSONS for the suggestion to document the header structure
  906.    ??? "{3}"           && various bit flags
  907.    ??? chr(year(dDate)-1900) + chr(month(dDate)) + ;
  908.        chr(day(dDate)) && date bytes in YYMMDD format
  909.    ??? "{0}{0}{0}{0}"  && no. of records
  910.    ??? "{193}{0}"      && no. of bytes in header
  911.    ??? "{19}{0}"       && no. of bytes per record
  912.    ??? "{0}{0}"        && reserved
  913.    ??? "{0}"           && incomplete transaction flag
  914.    ??? "{0}"           && encryption flag
  915.    ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}" + ;
  916.        "{0}{0}{0}"     && multi-user reserved
  917.    ??? "{0}"           && MDX flag
  918.    ??? "{0}{0}{0}"     && reserved
  919.    * field descriptors
  920.    ??? "{70}{73}{69}{76}{68}{95}{78}{65}{77}{69}{0}{67}{3}{0}{208}" + ;
  921.        "{72}{10}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"  && Field_Name
  922.    ??? "{70}{73}{69}{76}{68}{95}{84}{89}{80}{69}{0}{67}{13}{0}{208}" + ;
  923.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Type
  924.    ??? "{70}{73}{69}{76}{68}{95}{76}{69}{78}{0}{0}{78}{14}{0}{208}" + ;
  925.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Len
  926.    ??? "{70}{73}{69}{76}{68}{95}{68}{69}{67}{0}{0}{78}{17}{0}{208}" + ;
  927.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Dec
  928.    ??? "{70}{73}{69}{76}{68}{95}{73}{68}{88}{0}{0}{67}{20}{0}{208}" + ;
  929.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Idx
  930.    ??? "{13}{26}"
  931.    set printer to
  932.    set printer off
  933.  
  934. RETURN cFname
  935. *-- Eof() MakeStru2
  936.  
  937. FUNCTION TempName
  938. *-------------------------------------------------------------------------------
  939. *-- Programmer..: Martin Leon (HMAN)  Former Sysop, ATBBS
  940. *-- Date........: 05-27-1992
  941. *-- Notes.......: Obtain a name for a temporary file of a given extension
  942. *--               that does not conflict with existing files.
  943. *-- Written for.: dBASE IV, v1.5
  944. *-- Rev. History: Originally part of Makestru(), 6-12-1991
  945. *--               04/26/92, made a separate function - Jay Parsons
  946. *--               05/27/92, added lDBTMP option - Bowen Moursund
  947. *-- Calls.......: None
  948. *-- Called by...: Any
  949. *-- Usage.......: TempName( cExt , lDBTMP )
  950. *-- Example.....: Sortfile = TempName( "DBF" , .t. )
  951. *-- Returns.....: Name not already in use. Additionally, if the memvar
  952. *--               cDBTMP is declared before calling the function with
  953. *--               the lDBTMP option, it will be assigned the result
  954. *--               of getenv("DBTMP").
  955. *-- Parameters..: cExt   = Extension to be given file ( without the "." )
  956. *--               lDBTMP = Optional. If .t., function returns unique file
  957. *--                        name in the DBTMP subdirectory.
  958. *-- Side Effects: The function will return a unique filename for the DEFAULT
  959. *--               subdirectory if the lDBTMP option is used and the DOS
  960. *--               environment variable DBTMP does not point to a valid
  961. *--               subdirectory.
  962. *-------------------------------------------------------------------------------
  963.  
  964.    parameters cExt, lDBTMP
  965.    private all except cDBTMP
  966.    cDefDir = set("DIRECTORY")
  967.    if lDBTMP
  968.       cDBTMP = getenv("DBTMP")
  969.       if "" # cDBTMP
  970.          set directory to &cDBTMP.
  971.       endif
  972.    endif
  973.    do while .t.
  974.       Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  975.       if .not. file( Fname + "." + cExt ) .and. ( upper( cExt ) # "DBF" .or.;
  976.          .not. ( file( Fname + ".MDX" ) .or. file ( Fname + ".DBT" ) ) )
  977.             exit
  978.       endif
  979.    enddo
  980.    set directory to &cDefDir.
  981.  
  982. RETURN Fname
  983. *-- Eof() TempName
  984.  
  985. PROCEDURE FileMove
  986. *-------------------------------------------------------------------------------
  987. *-- Programmer..: David Frankenbach (FRNKNBCH)
  988. *--               DF Software Development, Inc.
  989. *--               PO Box 87
  990. *--               Forest, VA, 24551
  991. *--               (804) 237-2342
  992. *-- Date........: 02/11/1992
  993. *-- Notes.......: This procedure gives the record movement allowed with EDIT
  994. *--               when you use a simple @SAY/GET..READ. It allows you to
  995. *--               pre/post process each record during editing, something you
  996. *--               can't do with EDIT. This works best with a single file,
  997. *--               although it would work with a parent->child relation. You
  998. *--               should:  SELECT child and SET SKIP to child. This will
  999. *--               allow the user to change the parent record pointer though!
  1000. *--               If you want to limit the child record movement to a single
  1001. *--               parent record, you can use a conditional index, or add logic
  1002. *--               to the routine to limit the record pointer movement. For these
  1003. *--               cases I have a seperate FileMove procedure, but they are not
  1004. *--               generic enough for public consumption.
  1005. *--
  1006. *--               These keys are trapped:
  1007. *--               UpArw, Shift-Tab, LeftArw, Ctrl-LeftArw, PgUp = 
  1008. *--                                                         backward one record
  1009. *--               DnArw, Tab, RightArw, Ctrl-RightArw, PgDn, Enter, Ctrl-End = 
  1010. *--                                                         forward one record
  1011. *--               Ctrl-PgUp = top of database or active index
  1012. *--               Ctrl-PgDn = bottom of database or active index
  1013. *-- Written for.: dBASE IV, 1.1
  1014. *-- Rev. History: 06/17/1991 - original routine.
  1015. *--               02/07/1992 -- Ken Mayer, brought into one PROCEDURE,
  1016. *--               rather than a function and a procedure ...
  1017. *--               02/11/1992 -- Author, additional documentation
  1018. *--                             Released into Public Domain
  1019. *-- Calls.......: None
  1020. *-- Called by...: None
  1021. *-- Usage.......: do FileMove with <nKey>
  1022. *--               where: <nKey> is the return value of readkey()
  1023. *-- Example.....: lMove = .t.  && if you want the user to be able to move the 
  1024. *--                            && record pointer in my applications if the user
  1025. *--                            && is adding a new record I usually lMove = .f.,
  1026. *--                            && for editing I allow them to move through the
  1027. *--                            && records.
  1028. *--               lOk = .t.
  1029. *--               do while ( lOk )
  1030. *--                  do Mem_Load               && load memvars from record
  1031. *--                  @say/gets                 && display/get the memvars
  1032. *--                  read
  1033. *--                  i = readkey()             && grab last key ...
  1034. *--                  lOk = ( i <> 27 )         && if Esc was pressed lOK is false
  1035. *--                  if ( lOk )
  1036. *--                     if ( i > 256 )         && if record is changed
  1037. *--                        do Mem_Unload       && replace dbf fields from memvars
  1038. *--                     endif  && ( i > 256 )
  1039. *--                     if ( lMove )           && if ok to move record pointer
  1040. *--                        do FileMove with i  && <----- Move it
  1041. *--                     else
  1042. *--                        lOk = .f.            && terminate loop if .not. lMove
  1043. *--                     endif  && ( lMove )
  1044. *--                  endif && (lOK)
  1045. *--               enddo && while (lOK)
  1046. *-- Parameters..: nKey = last keystroke from a READKEY() call ...
  1047. *-- Returns.....: None
  1048. *-- Side Effects: Moves record pointer in current file if lMove = .t.
  1049. *-------------------------------------------------------------------------------
  1050.     parameter nKey
  1051.     private n
  1052.     
  1053.     m->n = m->nKey
  1054.     if ( m->n > 255 )     && if value is > 256, record has changed, but we want
  1055.        m->n = m->n - 256  && values < 256 to figure out which direction to move
  1056.     endif                 && from the readkey() table
  1057.     
  1058.     do case
  1059.     
  1060.        *-- keys to move backward through database 1 record at a time ...
  1061.        *--  LeftArw, Ctrl-LeftArw, UpArw, Shift-Tab, PgUp
  1062.        case ( m->n = 0 ) .or. ( m->n = 2 ) .or. ( m->n = 4 ) .or. ( m->n = 6 )
  1063.           if ( .not. bof() )                && if not at beginning of file
  1064.              skip -1                        && move backward one record
  1065.           endif
  1066.     
  1067.        *-- keys to move forward through database 1 record at a time ...
  1068.        *--  RightArw, Ctrl-RightArw, DownArw, Tab, PgDn, Ctrl-End, Enter
  1069.        case ( m->n = 1 ) .or. ( m->n = 3 ) .or. ( m->n = 5 ) .or. ( m->n = 7 );
  1070.              .or. ( m->n = 14) .or. ( m->n = 15)
  1071.           if ( .not. eof() )                && if not end of file
  1072.              skip 1                         && move forward one record
  1073.           endif
  1074.           if ( eof() )                      && if we're now at the EOF,
  1075.              goto bottom                    && go back to last record ...
  1076.           endif
  1077.     
  1078.        *-- go to toP of database, Ctrl-PgUp
  1079.        case ( m->n = 34 )
  1080.           goto top
  1081.     
  1082.        *-- go to BOTtoM of database, Ctrl-PgDn
  1083.        case ( m->n = 35 )
  1084.           goto bottom
  1085.     
  1086.     endcase
  1087.  
  1088. RETURN
  1089. *-- EoP: FileMove
  1090.  
  1091. FUNCTION Used
  1092. *-------------------------------------------------------------------------------
  1093. *-- Programmer..: Ken Mayer (KENMAYER)
  1094. *-- Date........: 05/15/1992
  1095. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1096. *--               from DBA Magazine (11/91) calls a function that checks
  1097. *--               to see if a DBF file is open ... the one he calls doesn't
  1098. *--               exist. This is designed to loop until all possible work
  1099. *--               areas are checked (for 1.1 this maxes at 10, for 1.5 it's
  1100. *--               40 ... this routine checks both). Written for PICK2,
  1101. *--               this should be transportable ...
  1102. *-- Written for.: dBASE IV, 1.5
  1103. *-- Rev. History: None
  1104. *-- Calls.......: None
  1105. *-- Usage.......: Used("<cFile>")
  1106. *-- Example.....: if used("Library")
  1107. *--                  select library
  1108. *--               else
  1109. *--                  select select()
  1110. *--                  use library
  1111. *--               endif
  1112. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1113. *-- Parameters..: cFile = file to check for
  1114. *-------------------------------------------------------------------------------
  1115.     
  1116.     parameters cFile
  1117.     private lReturn, nAlias, nMax
  1118.  
  1119.     *-- maximum # of work areas is based on version of dBASE ...
  1120.     *-- if 1.5 or higher, the max is 40, if 1.1 or lower, it's 10.
  1121.     if val(right(version(),3)) > 1.1
  1122.         nMax = 40
  1123.     else
  1124.         nMax = 10
  1125.     endif
  1126.     
  1127.     *-- a small loop
  1128.     nAlias = 0                          && start at 0, increment as we go
  1129.     lReturn = .f.                       && assume it's not open
  1130.     do while nAlias < nMax              && loop until we find it, or we max
  1131.         nAlias = nAlias + 1              && increment
  1132.         if alias(nAlias) = upper(cFile)  && is THIS the one?
  1133.             lReturn = .t.                 && if so, set lReturn to .t.
  1134.             exit                          &&   and exit the loop
  1135.         endif  && if alias ...
  1136.     enddo
  1137.     
  1138. RETURN lReturn
  1139. *-- EoF: Used
  1140.  
  1141. FUNCTION MDXbyte
  1142. *-------------------------------------------------------------------------------
  1143. *-- Programmer..: Bowen Moursund
  1144. *-- Date........: 05-21-1992
  1145. *-- Notes.......: Sets the MDX byte in a DBF header ON or OFF.
  1146. *--               The DBF must not be open when the function is called.
  1147. *-- Written for.: dBASE IV v1.5
  1148. *-- Rev. History: None
  1149. *-- Calls.......: dBASE low level file functions
  1150. *-- Called by...: Any
  1151. *-- Usage.......: MDXbyte(<cDBFpath>,<cOnOff>)
  1152. *-- Example.....: lByteSet = MDXbyte("mydbf.dbf","OFF")
  1153. *-- Returns.....: .T. if successful
  1154. *-- Parameters..: cDBFpath = the [path]filename.ext of the DBF
  1155. *--               cOnOff   = "ON" or "OFF"
  1156. *-------------------------------------------------------------------------------
  1157.  
  1158.    parameters cDBFpath,cOnOff
  1159.    private all
  1160.    cOnOff = upper(cOnOff)
  1161.    * check the validity of the parameters
  1162.    lSuccess = ( pcount() = 2 .AND. cOnOff $ "ON|OFF" .AND. file(cDBFpath) )
  1163.    if lSuccess
  1164.       nHandle = fopen(cDBFpath,"RW")
  1165.       if nHandle > 0
  1166.          if fseek(nHandle, 28) = 28
  1167.             lSuccess = ( fwrite(nHandle, iif(cOnOff="OFF",chr(0),chr(1))) = 1 )
  1168.          else
  1169.             lSuccess = .F.
  1170.          endif
  1171.          lClosed = fclose(nHandle)
  1172.       else
  1173.          lSuccess = .F.
  1174.       endif
  1175.    endif
  1176.  
  1177. RETURN lSuccess
  1178. *-- Eof() MDXbyte
  1179.  
  1180. FUNCTION aDir
  1181. *-------------------------------------------------------------------------------
  1182. *-- Programmer..: Bowen Moursund
  1183. *-- Date........: 07-24-1992
  1184. *-- Notes.......: aDir() creates a public array gaDir[ n, 5 ] containing
  1185. *--               directory information. gaDir[ n, 5 ] is limited to 234
  1186. *--               rows (files) or less, depending on the memory available.
  1187. *--
  1188. *--                     Structure of 2D array gaDir[ n, 5 ]:
  1189. *--
  1190. *--                     Col  Contents             Type       Width
  1191. *--                     ------------------------------------------
  1192. *--                       1  File Name            Character     12
  1193. *--                       2  Date (mm/dd/yy)      Date           8
  1194. *--                       3  Time (hh:mm:ss)      Character      8
  1195. *--                       4  Size (bytes)         Numeric       10
  1196. *--                       5  Attributes           Character      6
  1197. *--
  1198. *--               aDir() makes use of Search.Bin, and credit is due its
  1199. *--               author. See ASM source for details.
  1200. *--               *****************************
  1201. *--               **** REQUIRES SEARCH.BIN ****
  1202. *--               *****************************
  1203. *-- Written for.: dBASE IV, v1.5
  1204. *-- Rev. History: None
  1205. *-- Calls.......: None
  1206. *-- Called by...: Any
  1207. *-- Usage.......: adir( <cFMask>, <cBINpath>, <cAttr> )
  1208. *-- Examples....: nFiles = adir( "d:\app\fu*.db?", "d:\dbase4\library\", "" )
  1209. *--               nFiles = adir( cPathSkel )
  1210. *--               nFiles = adir( "c:\*.*", "", "RHSD" )
  1211. *-- Returns.....: Number of matching files found: rows in gaDir[]
  1212. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1213. *--                           want, like the DOS DIR command. Wildcards OK.
  1214. *--               cBINpath = Optional path to Search.Bin. If omitted,
  1215. *--                          Search.Bin must be in current subdirectory.
  1216. *--                          Include the trailing backslash.
  1217. *--               cAttr = Optional file attribute mask string.
  1218. *--
  1219. *--                             Mask Codes
  1220. *--                            ------------
  1221. *--                            R - Read Only
  1222. *--                            H - Hidden
  1223. *--                            S - System
  1224. *--                            D - Directory
  1225. *--                            V - Volume
  1226. *--                            A - Archive
  1227. *--
  1228. *--                       If cAttr is omitted, null, or blank, gaDir[] will
  1229. *--                       contain only 'ordinary' files, i.e. files without
  1230. *--                       HSDV attributes. If V is specified in the mask,
  1231. *--                       ONLY volume labels are matched. Any other attribute
  1232. *--                       or combination of attributes results in those files
  1233. *--                       AND ordinary files being matched.
  1234. *-------------------------------------------------------------------------------
  1235.  
  1236.     parameters cPathSkel, cBINpath, cAttr
  1237.     private all except gaDir
  1238.     cModule = iif( pcount() >= 2, cBINpath + "search.bin", "search.bin" )
  1239.     store upper( iif( pcount() >= 3, left( cAttr + "      ", 6 ), "      " ) ) ;
  1240.                  to cAttr, cFAttr
  1241.     cFSkel = left( cPathSkel + space(12), max( len( cPathSkel ), 12 ) )
  1242.     cFName = cFSkel
  1243.     * ( memory() * 3.4 ) is a guess on max rows before 'Insufficient Memory'
  1244.     nMaxRows = min( memory() * 3.4, 234 )  && 234 is the absolute maximum
  1245.     nFCount = 0
  1246.     load ( cModule )
  1247.     nResult = call( "Search", 1, cFName, cAttr )
  1248.     if nResult = 0
  1249.         do while nResult = 0 .and. nFCount <= nMaxRows
  1250.             nFCount = nFCount + 1
  1251.             nResult = call( "Search" , 2, cFName )
  1252.         enddo
  1253.         nFCount = min( nMaxRows, nFCount )
  1254.         release gaDir
  1255.         public array gaDir[ nFCount, 5 ]
  1256.         cFName = cFSkel
  1257.         cFDate = "  /  /  "
  1258.         cFTime = "  :  :  "
  1259.         nFSize = 0
  1260.         n = 1
  1261.         nResult = ;
  1262.         call( "Search", 1, cFName, cFAttr, cFDate, cFTime, nFSize )
  1263.         do while nResult = 0 .AND. n <= nFCount
  1264.             store cFName to         gaDir[ n, 1 ]
  1265.             store ctod( cFDate ) to gaDir[ n, 2 ]
  1266.             store cFTime to         gaDir[ n, 3 ]
  1267.             store nFSize to         gaDir[ n, 4 ]
  1268.             store cFAttr to         gaDir[ n, 5 ]
  1269.             nResult = ;
  1270.              call( "Search", 2, cFName, cFAttr, cFDate, cFTime, nFSize )
  1271.             n = n + 1
  1272.         enddo
  1273.     else
  1274.         release gaDir
  1275.     endif
  1276.     release module Search
  1277.  
  1278. RETURN nFCount
  1279. *-- EoF: aDir()
  1280.  
  1281. FUNCTION DbfDir
  1282. *-------------------------------------------------------------------------------
  1283. *-- Programmer..: Bowen Moursund
  1284. *-- Date........: 07-03-1992
  1285. *-- Notes.......: DbfDir() creates or OVERWRITES DdbDir.Dbf, and populates
  1286. *--               it with directory information. The function uses the DOS
  1287. *--               5.0 DIR command and requires DOS 5.0.
  1288. *--
  1289. *--                          Structure of DBFDIR.DBF
  1290. *--                          -----------------------
  1291. *--                          Field    Type  Len  Dec
  1292. *--                          F_NAME      C   12    0
  1293. *--                          F_DATE      D    8    0
  1294. *--                          F_TIME      C    8    0
  1295. *--                          F_SIZE      N   10    0
  1296. *--               *********************************************************
  1297. *--               * DO NOT CALL THIS ROUTINE WHILE PRINTING (the function *
  1298. *--               * uses Print Redirection ...)                           *
  1299. *--               *********************************************************
  1300. *-- Written for.: dBASE IV v1.5, DOS 5.0
  1301. *-- Rev. History: None
  1302. *-- Calls.......: TempName()           Function in FILES.PRG
  1303. *-- Called by...: None
  1304. *-- Usage.......: DbfDir( "<cPathSkel>", <lHidSys> )
  1305. *-- Examples....: nFiles = DbfDir( "*.dbf" )
  1306. *--               nFiles = DbfDir( "*.dbf", .t. )
  1307. *-- Returns.....: Number of matching files found: reccount() of DbfDir.dbf
  1308. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1309. *--                           want, like the DOS DIR command. Wildcards OK.
  1310. *--               lHidSys   = Optional. If .t., hidden & system files
  1311. *--                           are included.
  1312. *-------------------------------------------------------------------------------
  1313.  
  1314.     parameters cPathSkel, lHidSys
  1315.     private all
  1316.     cDBTMP = ""
  1317.     cTmpFile = tempname( "txt", .t. ) + ".txt"
  1318.     cTmpFile = iif( "" = cDBTMP, cTmpFile, cDBTMP + "\" + cTmpFile )
  1319.     cDirParms = iif( lHidSys, "/B/A-D/ON", "/B/A-D-H-S/ON" )
  1320.     run dir &cPathSkel. &cDirParms. > &cTmpFile.
  1321.     nFiles = 0
  1322.     if fsize( cTmpFile ) > 0
  1323.         lSafeOn = ( set( "safety" ) = "ON" )
  1324.         set safety off
  1325.         set printer to file DbfDir.dbf  && create DbfDir.dbf
  1326.         set printer on
  1327.         * first byte of header - various bit flags
  1328.         ??? "{3}"
  1329.         * next 3 bytes - file date in binary YYMMDD
  1330.         ??? chr(year(date())-1900) + chr(month(date())) + chr(day(date()))
  1331.         * the rest of the header, field descriptors, and records if any
  1332.         ??? "{0}{0}{0}{0}{161}{0}{39}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1333.         "{0}{0}{0}{0}{0}{0}{0}{1}{1}{70}{95}{78}{65}{77}{69}{0}{0}{0}{0}{0}"+;
  1334.         "{67}{0}{0}{0}{0}{12}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1335.         "{70}{95}{68}{65}{84}{69}{0}{0}{0}{0}{0}{68}{0}{0}{0}{0}"
  1336.         ??? "{8}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{84}"+;
  1337.         "{73}{77}{69}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}{8}{0}{0}{0}{0}{0}{0}"+;
  1338.         "{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{83}{73}{90}{69}{0}{0}{0}{0}{0}"+;
  1339.         "{78}{0}{0}{0}{0}{10}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1340.         ??? "{0}{0}{0}{13}{26}"
  1341.         set printer to
  1342.         set printer off
  1343.         cAlias = alias()
  1344.         select select()
  1345.         use DbfDir
  1346.         append from ( cTmpFile ) sdf
  1347.         goto top
  1348.         cPath = parspath( cPathSkel )
  1349.         scan
  1350.             replace f_size with fsize( cPath + f_name ),;
  1351.                     f_date with fdate( cPath + f_name ),;
  1352.                     f_time with ftime( cPath + f_name )
  1353.         endscan
  1354.         nFiles = reccount()
  1355.         use
  1356.         if lSafeOn
  1357.             set safety on
  1358.         endif
  1359.         if "" # cAlias
  1360.             select ( cAlias )
  1361.         endif
  1362.     endif
  1363.     erase ( cTmpFile )
  1364.  
  1365. RETURN nFiles
  1366. *-- EoF: DBFDir()
  1367.  
  1368. FUNCTION ParsPath
  1369. *-------------------------------------------------------------------------------
  1370. *-- Programmer..: Bowen Moursund
  1371. *-- Date........: 07-16-1992
  1372. *-- Notes.......: ParsPath() extracts and returns the path from a
  1373. *--               full path file specification.
  1374. *-- Written for.: dBASE IV v1.1
  1375. *-- Rev. History: None
  1376. *-- Calls.......: None
  1377. *-- Called by...: Any
  1378. *-- Usage.......: ParsePath( "<cFullPath>" )
  1379. *-- Example.....: set fullpath on
  1380. *--               cDBF = dbf()
  1381. *--               cPath = ParsPath( cDBF )
  1382. *-- Returns.....: The path only, including the trailing backslash,
  1383. *--               of the full path file specification
  1384. *-- Parameters..: cFullPath = a full path file spec, e.g. "c:\dbase\dbase.exe"
  1385. *-------------------------------------------------------------------------------
  1386.  
  1387.     parameter cFullPath
  1388.     private all
  1389.     cPath = ""
  1390.     if "\" $ cFullPath
  1391.         nPos = 1
  1392.         do while left( right ( cFullPath, nPos ), 1 ) # "\"
  1393.             nPos = nPos + 1
  1394.         enddo
  1395.         cPath = substr( cFullPath, 1, len( cFullPath ) - nPos + 1)
  1396.     endif
  1397.  
  1398. RETURN cPath
  1399. *-- EoF: ParsPath()
  1400.  
  1401. PROCEDURE TagPop
  1402. *-------------------------------------------------------------------------------
  1403. *-- Programmer..: Ken Mayer (KENMAYER)
  1404. *-- Date........: 09/08/1992
  1405. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  1406. *--               so they can change the current tag ... This is based on an
  1407. *--               article by Susan Perschke and Mike Liczbanski in "Data Based 
  1408. *--               Advisor", December, 1991, and another by Malcom C. Rubel,
  1409. *--               Data Based Advisor, September, 1992.
  1410. *--                 The idea is to bring up a picklist of all MDX tags for
  1411. *--               the current database file, showing the tag name, and 
  1412. *--               expression, as well as whether or not it's unique, has a
  1413. *--               FOR clause, and whether it's ascending or descending ...
  1414. *--                 However, as an additional bonus, if the user selects one
  1415. *--               of the MDX tags, the current tag is changed to the one the
  1416. *--               user selects. The tag with a "*" by it is the current tag.
  1417. *-- Written for.: dBASE IV, 1.5
  1418. *-- Rev. History: 09/08/1992 -- Version 1
  1419. *--               09/21/1992 -- Version 1.1 -- added more docs and removed
  1420. *--                               reference to parameters of which there are
  1421. *--                               none ... (changed my mind)
  1422. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1423. *--               CENTER               Procedure in PROC.PRG
  1424. *-- Called by...: Any
  1425. *-- Usage.......: DO TagPop
  1426. *-- Example.....: ON KEY LABEL F8 DO TagPop
  1427. *-- Returns.....: None (well, ok -- it resets the MDX tag if you select one)
  1428. *-- Parameters..: None
  1429. *-------------------------------------------------------------------------------
  1430.  
  1431.     private nBar, cPrompt, cBorder, cTag, nTag, nTagTotal, cFor, cUnique,;
  1432.              cDir, cKey
  1433.     
  1434.     *-- Disable left/right arrow keys to prevent an accidental exit
  1435.     on key label leftarrow  ?? chr(7)
  1436.     on key label rightarrow ?? chr(7)
  1437.     
  1438.     *-- Save current screen
  1439.     save screen to sTag
  1440.     cBorder = set("BORDER")
  1441.     activate screen
  1442.     
  1443.     *-- define the screen/window
  1444.     define window wTagPop from 5,2 to 20,77 double
  1445.     activate screen
  1446.     do shadow with 5,2,20,77
  1447.     activate window wTagPop
  1448.     
  1449.     *-- check to see if there are any tags ... or an active database ...
  1450.     if isblank(alias()) .or. isblank(tag(1))
  1451.     
  1452.         *-- if not, display appropriate error message
  1453.         if isblank(alias())
  1454.             do center with 1,75,"","** No active Database ... **"
  1455.         else
  1456.             do center with 1,75,"","** No active .MDX file for this .DBF **"
  1457.         endif
  1458.         x=inkey(0)  && wait for user to press a key ...
  1459.         
  1460.     else   && we DO have an active database AND active MDX file
  1461.     
  1462.         *-- headings
  1463.         do center with 0,75,"","Select new MDX Tag"
  1464.         @2,1 say "Name"
  1465.         @2,10 say "For"
  1466.         @2,14 say "Unq"
  1467.         @2,18 say "Seq"
  1468.         @2,22 say "Expression"
  1469.         @3,1 say replicate(chr(196),72)  && ─
  1470.         
  1471.         *-- popup will display here
  1472.         
  1473.         *-- footings (as it were)
  1474.         @10,1 say replicate(chr(196),72)  && ─
  1475.         @11,3 say chr(251)+" in 'For' column means there is a 'For' clause"
  1476.         @12,3 say chr(251)+" in 'Unq' column means the tag is set to 'Unique'"
  1477.         @13,3 say chr(24)+" in 'Seq' means tag is 'Ascending', "+;
  1478.             chr(25)+" means tag is descending"
  1479.         
  1480.         *-- define the popup
  1481.         set border to none  && no border for popup
  1482.         define popup pTag from 3,0 to 10,73;
  1483.            message " Press ENTER to select new index order ... ESC to exit ..."
  1484.         nBar = 1                        && first bar
  1485.         *-- place a * if no tag is currently active
  1486.         cPrompt = iif(TagNo()=0,"*"," ")+" No Index"  && bar 1 will always be this
  1487.         cPrompt = cPrompt + space(11)+"(Natural Order)"
  1488.         nTag = 0
  1489.         
  1490.         *-- loop to get the rest of 'em ...
  1491.         nTagTotal = tagcount()           && get total number of tags
  1492.         do while nTag <= nTagTotal       && loop until no more tags
  1493.            define bar nBar of pTag prompt (cPrompt)
  1494.             nTag = nTag + 1
  1495.             cDefault = iif(TagNo() = nTag,"*"," ")  && if current tag ...
  1496.             *-- the fun part of all this is getting the spacing "just right"
  1497.             *-- that's what all the IIF( ....,space(...)) stuff is about
  1498.             cTag    = tag(nTag)+iif(len(tag(nTag))<9,space(9-len(tag(nTag))),"")
  1499.             cFor    = iif(isblank(for(nTag))," ",chr(251))
  1500.             cUnique = iif(unique(nTag),chr(251)," ")
  1501.             cDir    = iif(descending(nTag),chr(25),chr(24)) && up/down arrows ...
  1502.             cKey    = iif(len(key(nTag))>57,left(key(nTag),52)+" ...",key(nTag))
  1503.             cKey    = iif(len(cKey)<57,cKey+space(57-len(cKey)),cKey)
  1504.             *-- here's the actual definition of the bars ...
  1505.            cPrompt = cDefault+cTag+"  "+cFor+"  "+cUnique+"  "+cDir+"  "+cKey
  1506.            nBar = nBar + 1
  1507.         enddo
  1508.         
  1509.         *-- turn it off when an item's been selected (or <Esc> was pressed)
  1510.         on selection popup pTag deactivate popup
  1511.         
  1512.         *-- do it
  1513.         activate popup pTag
  1514.         
  1515.         *-- Don't change index order if ESC pressed
  1516.         if bar() <> 0
  1517.             *-- Assign a null string to cPrompt if "No Index" selected
  1518.             cPrompt = iif(bar() = 1, "",tag(bar()-1))
  1519.            set order to (cPrompt)
  1520.         endif
  1521.         
  1522.         *-- cleanup
  1523.         release popup pTag
  1524.         set border to &cBorder
  1525.         
  1526.     endif
  1527.     deactivate window wTagPop
  1528.     release window wTagPop
  1529.     restore screen from sTag
  1530.     release screen sTag
  1531.     
  1532.     *-- re-enable left/right arrow keys
  1533.     on key label leftarrow
  1534.     on key label rightarrow
  1535.  
  1536. RETURN
  1537. *-- EoP: TagPop
  1538.  
  1539. FUNCTION AAppend
  1540. *-------------------------------------------------------------------------------
  1541. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1542. *-- Date........: 04/xx/1992
  1543. *-- Notes.......: Appends a text file into an array. This routine is limited to
  1544. *--               text files of 1,170 lines, and 254 characters per line.
  1545. *--               The text file must be an ASCII Txt formatted file. Taken from
  1546. *--               Technotes, April, 1992.
  1547. *-- Written for.: dBASE IV, 1.5
  1548. *-- Rev. History: None
  1549. *-- Calls.......: TextLine()           Function in LOWLEVEL.PRG
  1550. *-- Called by...: Any
  1551. *-- Usage.......: AAppend(<cFileName>,<aArrayName>)
  1552. *-- Example.....: ?AAppend("CONFIG.DB","aConfig")
  1553. *-- Returns.....: .T.
  1554. *-- Parameters..: cFileName  = Name of DOS Text file to read into array
  1555. *--               aArrayName = Name of array to create. If it already exists,
  1556. *--                            this array will be destroyed and overwritten.
  1557. *-------------------------------------------------------------------------------
  1558.  
  1559.    parameters cFileName, aArrayName
  1560.    private aTArray, nLines, nX, nHandle
  1561.  
  1562.    *-- assign array name to a temp variable name ...
  1563.    aTArray = aArrayName
  1564.    *-- if it exists, get rid of it, and then re-define it
  1565.    release &aTArray
  1566.    public  &aTArray
  1567.    nLines = TextLine(cFileName)  && get number of lines
  1568.    declare &aTArray[min(nLines,1170)]
  1569.  
  1570.    *-- get file handle
  1571.    nHandle = fopen(cFileName)
  1572.  
  1573.    *-- store the file into the array
  1574.    nX = 1
  1575.    do while nX <= nLines
  1576.       store fgets(nHandle,254) to &aTArray[nX]
  1577.       nX = nX + 1
  1578.    enddo
  1579.  
  1580.    *-- close the file
  1581.    nHandle = fClose(nHandle)
  1582.  
  1583. RETURN .T.
  1584. *-- EoF: AAppend()
  1585.  
  1586. FUNCTION FDel
  1587. *-------------------------------------------------------------------------------
  1588. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1589. *-- Date........: 04/xx/1992
  1590. *-- Notes.......: Deletes a given portion of a file. Taken from TechNotes,
  1591. *--               April, 1992
  1592. *--                 Used to delete a portion of a file (text or binary) from
  1593. *--               the beginning of the file, the end of file or current pointer
  1594. *--               position. This routine accomplishes it's task by writing the
  1595. *--               data you want to keep to a temp file, then overwriting
  1596. *--               the data you no longer want with the temp file. If you are on
  1597. *--               a network, make sure that you set TMP (or DBTMP) to either
  1598. *--               a local drive, or one where you have full rights.
  1599. *-- Written for.: dBASE IV, 1.5
  1600. *-- Rev. History: None
  1601. *-- Calls.......: TempFile()           Function in LOWLEVEL.PRG
  1602. *-- Called by...: Any
  1603. *-- Usage.......: FDel(<nHandle>,<nBytes>,<nStart>)
  1604. *-- Example.....: nOpen = fopen("TEXT.TXT","RW")
  1605. *--               ?FDel(nOpen,1000,1)
  1606. *-- Returns.....: Logical
  1607. *-- Parameters..: nHandle = file handle number, as returned by FOPEN
  1608. *--               nBytes  = number of characters (bytes) to delete in file
  1609. *--               nStart  = starting position, where:
  1610. *--                          0 is the beginning of the file
  1611. *--                          1 is the current file pointer position
  1612. *--                          2 is the end of the file
  1613. *-------------------------------------------------------------------------------
  1614.  
  1615.    parameters nHandle, nBytes, nStart
  1616.    private nTemp,cTemp,nSave,nSeek,nRead,nWrite,lFlush,nClose
  1617.  
  1618.    *-- create a temporary file
  1619.    cTemp = tempfile("ADM")
  1620.    *-- save current position in file
  1621.    nSave = fseek(nHandle,0,1)
  1622.  
  1623.    do case
  1624.       case nStart = 0                  && beginning of file
  1625.            nSeek = fseek(nHandle,nBytes,0)
  1626.            nTemp = fcreate(cTemp)
  1627.            do while .not. feof(nHandle)
  1628.               nRead = fread(nHandle,254)
  1629.               nWrite = fwrite(nTemp,nRead)
  1630.               lFlush = fflush(nTemp)
  1631.            enddo
  1632.            nSeek = fseek(nTemp,0,0)
  1633.            nSeek = fseek(nHandle,0,0)
  1634.            do while .not. feof(nTemp)
  1635.               nRead = fread(nTemp,254)
  1636.               nWrite = fwrite(nHandle,nRead)
  1637.               lFlush = fflush(nHandle)
  1638.            enddo
  1639.            nWrite = fwrite(nHandle,chr(0),0)
  1640.            nClose = fclose(nTemp)
  1641.            nSeek = fseek(nHandle,nSave,0)
  1642.  
  1643.       case nStart = 1                  && Current Location
  1644.            *-- skip these bytes
  1645.            nSeek = fseek(nHandle,nDelete,1)
  1646.            *-- write the rest to a temp file
  1647.            nTemp=fCreate(cTemp)
  1648.            do while .not. feof(nHandle)
  1649.               nRead = fread(nHandle,254)
  1650.               nWrite = fwrite(nTemp,nRead)
  1651.               lFlush = fflush(nTemp)
  1652.            enddo
  1653.  
  1654.            nSeek = fseek(nTemp,0,0)
  1655.            nSeek = fseek(nHandle,nSave,0)
  1656.            nWrite = fwrite(nHandle,chr(0),0)
  1657.  
  1658.            do while .not. feof(nTemp)
  1659.               nRead = fread(nTemp,254)
  1660.               nWrite = fwrite(nHandle,nRead)
  1661.               lFlush = fflush(nHandle)
  1662.            enddo
  1663.            nSeek = fseek(nHandle,nSave,0)
  1664.            nClose = fclose(nTemp)
  1665.  
  1666.       case nStart = 2                  && End of File
  1667.            nSeek = fseek(nHandle,-1*abs(nDelete),2)
  1668.            nWrite = fwrite(nHandle,chr(0),0)
  1669.    endcase
  1670.    erase (cTemp)
  1671.  
  1672. RETURN (ferror() = 0)
  1673. *-- EoF: FDel()
  1674.  
  1675. FUNCTION FGetLine
  1676. *-------------------------------------------------------------------------------
  1677. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1678. *-- Date........: 04/xx/1992
  1679. *-- Notes.......: Used to extract a line of text from a text file. 
  1680. *-- Written for.: dBASE IV, 1.5
  1681. *-- Rev. History: None
  1682. *-- Calls.......: TLine()              Function in LOWLEVEL.PRG
  1683. *--               TLineNo()            Function in LOWLEVEL.PRG
  1684. *-- Called by...: Any
  1685. *-- Usage.......: FGetLine(<cFileName>,<cLookup>,[<lCase>],[<lEntire>])
  1686. *-- Example.....: ?FGetLine("config.db","command",.f.,.f.)
  1687. *-- Returns.....: A character expression
  1688. *-- Parameters..: cFileName = Name of file to extract text from
  1689. *--               cLookup   = Text to look for
  1690. *--               lCase     = Case sensitive? (Logical = .t. or .f.)
  1691. *--                           If empty, default is .F.
  1692. *--               lEntire   = Return entire line, or the rest of the line
  1693. *--                           .t. = return the entire line
  1694. *--                           .f. = return everything following cLookup
  1695. *--                           If empty, default is .t.
  1696. *-------------------------------------------------------------------------------
  1697.  
  1698.    parameters cFileName, cLookup, lCase, lEntire
  1699.    private nLine, cText
  1700.  
  1701.    *-- defaults
  1702.    lCase   = iif(pcount() <= 2,.f.,lCase)
  1703.    lEntire = iif(pcount() <=3,.t.,lEntire)
  1704.    *-- get the line ...
  1705.    nLine = TLineNo(cFile,cLookup,lCase)
  1706.    cText = iif(nLine<=0,"",TLine(cFile,nLine,lCase))
  1707.    cResult = upper(cText)
  1708.  
  1709. RETURN iif(lEntire,cText,substr(cText,at(upper(cLookup),cResult)+len(cLookup)))
  1710. *-- EoF: FGetLine()
  1711.  
  1712. FUNCTION FIns
  1713. *-------------------------------------------------------------------------------
  1714. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1715. *-- Date........: 04/xx/1992
  1716. *-- Notes.......: Inserts specified number of NULLS into a low-level file.
  1717. *--               Taken from Technotes, April, 1992. FIns() works the way
  1718. *--               FDel() works, but in reverse.  See comments in FDel about
  1719. *--               temp directory ...
  1720. *-- Written for.: dBASE IV, 1.5
  1721. *-- Rev. History: None
  1722. *-- Calls.......: TempFile()           Function in LOWLEVEL.PRG
  1723. *-- Called by...: Any
  1724. *-- Usage.......: FIns(<nHandle>,<nBytes>,<nStart>)
  1725. *-- Example.....: nOpen = fopen("TEST.TXT","RW")
  1726. *--               ?FIns(nOpen,10,1)
  1727. *-- Returns.....: Logical
  1728. *-- Parameters..: nHandle = File Handle from FOPEN() function
  1729. *--               nBytes  = Number of nulls to insert into file
  1730. *--               nStart  = Location in file to start at, where:
  1731. *--                         0 = Beginning of file
  1732. *--                         1 = Current file pointer
  1733. *--                         2 = End of file
  1734. *-------------------------------------------------------------------------------
  1735.  
  1736.    parameters nHandle, nBytes, nStart
  1737.    private nTemp, cTemp, nSave, nRead, nWrite, nSeek, lFlush, nX, nClose
  1738.  
  1739.    cTemp = TempFile("ADM")      && create temp file
  1740.    nSave = fseek(nHandle,0,1)   && save current position
  1741.  
  1742.    do case
  1743.       case nStart = 0           && beginning of file
  1744.            nTemp = fcreate(cTemp)
  1745.            nX = 1
  1746.            do while nX <= nBytes
  1747.               nWrite = fwrite(nTemp,chr(0),1)
  1748.               nX = nX + 1
  1749.            enddo
  1750.            nSeek = fseek(nHandle,0,0)
  1751.            do while .not. feof(nHandle)
  1752.               nRead = fread(nHandle,254)
  1753.               nWrite = fwrite(nTemp,nRead)
  1754.               lFlush = fflush(nTemp)
  1755.            enddo
  1756.            nSeek = fseek(nTemp,0,0)
  1757.            nSeek = fseek(nHandle,0,0)
  1758.            do while .not. feof(nTemp)
  1759.               nRead = fread(nTemp,254)
  1760.               nWrite = fwrite(nHandle,nRead)
  1761.               lFlush = fflush(nHandle)
  1762.            enddo
  1763.            nWrite = fwrite(nHandle,chr(0),0)
  1764.            nclose = fclose(ntemp)
  1765.            nSeek = fseek(nHandle,0,0)
  1766.  
  1767.       case nStart = 1                  && current location
  1768.            *-- write the rest to a temp file
  1769.            nTemp = fcreate(cTemp)
  1770.            do while .not. feof(nHandle)
  1771.               nRead = fread(nHandle,254)
  1772.               nWrite = fwrite(nTemp,nRead)
  1773.               lFlush = fflush(nTemp)
  1774.            enddo
  1775.            nSeek = fseek(nHandle,nSave,0)
  1776.            nX = 1
  1777.            do while nX <= nBytes
  1778.               nWrite = fWrite(nHandle,chr(0),1)
  1779.               nX = nX + 1
  1780.            enddo
  1781.            nSeek = fseek(nTemp,0,0)
  1782.            do while .not. feof(nTemp)
  1783.               nRead = fread(nTemp,254)
  1784.               nWrite = fwrite(nHandle,nRead)
  1785.               lFlush = fflush(nHandle)
  1786.            enddo
  1787.            nSeek = fseek(nHandle,nSave,0)
  1788.            nClose = fclose(nTemp)
  1789.  
  1790.       case nStart = 2                  && End of File
  1791.            nSeek = fseek(nHandle,0,2)
  1792.            nX = 1
  1793.            do while nX <= nBytes
  1794.               nWrite = fwrite(nHandle,chr(0),1)
  1795.               nX = nX + 1
  1796.            enddo
  1797.    endcase
  1798.    erase (cTemp)
  1799.  
  1800. RETURN (ferror() = 0)
  1801. *-- EoF: FIns()
  1802.  
  1803. FUNCTION GetInfo
  1804. *-------------------------------------------------------------------------------
  1805. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1806. *-- Date........: 04/xx/1992 
  1807. *-- Notes.......: This retrieves information from STATUS that you cannot get
  1808. *--               with the dBASE IV function SET(). See 'parameters' below for
  1809. *--               list of keywords.
  1810. *--               CAUTION: If you have ALTERNATE set, you need to reset it after
  1811. *--                 the function executes. SET ALTERNATE TO must be used instead
  1812. *--                 of LIST STATUS TO filename, since the print destination
  1813. *--                 would always show as a file. All results that are returned
  1814. *--                 are returned as character types, including ones that
  1815. *--                 return numbers (use VAL() to look at/use returned value as
  1816. *--                 a number).
  1817. *-- Written for.: dBASE IV, 1.5
  1818. *-- Rev. History: None
  1819. *-- Calls.......: TempFile()           Function in LOWLEVEL.PRG
  1820. *--               TextLine()           Function in LOWLEVEL.PRG
  1821. *--               AAppend()            Function in LOWLEVEL.PRG
  1822. *-- Called by...: Any
  1823. *-- Usage.......: GetInfo(<cKeyWord>,[<cKeyWord2>])
  1824. *-- Example.....: ? GetInfo("F5")
  1825. *-- Returns.....: Character expression
  1826. *-- Parameters..: cKeyWord  = Item you are looking for status of, options 
  1827. *--                           listed return the following:
  1828. *--                           WORK    Number of work area you are currently
  1829. *--                                   in - whether or not a database is in use.
  1830. *--                           PRINT   Current printer destination where output
  1831. *--                                   is directed (PRN, NUL, LPT1, COM1) as 
  1832. *--                                   set by SET PRINTER TO.
  1833. *--                           ERROR   The error condition set by ON ERROR
  1834. *--                           ESCAPE  The escape condition set by ON ESCAPE
  1835. *--                           F2 to F10, Ctrl-F1 to Ctrl-F10, Shift-F1 to
  1836. *--                              Shift-F10 
  1837. *--                                   The current setting of each key as set
  1838. *--                                   by SET FUNCTION <label> TO
  1839. *--                           **** The following require a second paramter
  1840. *--                                (cKeyWord2 ...)
  1841. *--                           PAGE,LINE  Line number specified by 
  1842. *--                                                 ON PAGE AT LINE
  1843. *--                                      in the page handling routine
  1844. *--                           HANDLE,<filename>  The handle number of the low-
  1845. *--                                      level file specified by <filename>
  1846. *--                           NAME,<filehandle>  The file name of the low-level
  1847. *--                                      file specified by <filehandle>
  1848. *--                           MODE,<filehandle>  The privilege of the low-level
  1849. *--                                      file specified by <filehandle>
  1850. *--               cKeyWord2 = see list above ...
  1851. *-------------------------------------------------------------------------------
  1852.  
  1853.    parameters cKeyWord, cKeyWord2
  1854.    private cKey, l2Parms, cStart, cSafety, cTempTxt, nLines, cTmpArray
  1855.  
  1856.    cKey = upper(cKeyWord)
  1857.    l2Parms = (pcount() = 2)
  1858.  
  1859.    do case
  1860.       case cKey = "CTRL-" .or. cKey = "SHIFT" .or. ;
  1861.            (","+cKey+"," $ ",F2,F3,F4,F5,F6,F7,F8,F9,F10,")
  1862.            cStart = cKey + space(9 - len(cKey))+"-"
  1863.  
  1864.       case cKey = "PRINT"
  1865.            cStart = "Print Destination:"
  1866.  
  1867.       case cKey = "WORK"
  1868.            cStart = "Current work area ="
  1869.            if "" <> dbf()
  1870.               RETURN select(alias())
  1871.            endif
  1872.  
  1873.       case cKey = "ERROR"
  1874.            cStart = "On Error:"
  1875.         
  1876.       case cKey = "ESCAPE"
  1877.            cStart = "On Escape:"
  1878.  
  1879.       case cKey = "PAGE"
  1880.            cStart = "On Page At Line"
  1881.  
  1882.       case cKey = "HANDLE" .or. cKey = "NAME" .or. cKey = "MODE"
  1883.            cStart = "Low level files opened"
  1884.  
  1885.       otherwise      && none of the above
  1886.            RETURN ""
  1887.  
  1888.    endcase
  1889.  
  1890.    cSafety = set("SAFETY")
  1891.    cTempTxt = TempFile()
  1892.    *-- get status info (into a temp file), which will then be parsed to extract
  1893.    *-- information requested ...
  1894.    set console off
  1895.    set alternate to &cTempTxt.  && create file without extension
  1896.    set alternate on
  1897.    list status
  1898.    close alternate
  1899.    set console on
  1900.    
  1901.    nLines = TextLine(cTempTxt)
  1902.    aTmpArray = right(cTempTxt,8)
  1903.    cTmp = AAppend(cTempTxt,aTmpArray)
  1904.    nHandle = fopen(cTempTxt,"R")
  1905.    cResult = ""
  1906.  
  1907.    nX = 1
  1908.    do while nX <= nLines
  1909.       if left(&aTmpArray[nX],len(cStart)) = cStart
  1910.          cResult = ltrim(substr(&aTmpArray[nX],len(cStart)+1))
  1911.          exit
  1912.       endif
  1913.       nX = nX + 1
  1914.    enddo
  1915.  
  1916.    *-- 2 parameters?
  1917.    if l2Parms .and. "" # cResult
  1918.       do case
  1919.          case cKey = "PAGE"
  1920.               if upper(cKeyWord2) = "LINE"
  1921.                  cResult = left(cResult,at(" ",cResult) - 1)
  1922.               else
  1923.                  cResult = substr(cResult,at(" ",cResult) + 1)
  1924.               endif
  1925.  
  1926.          case cKey = "HANDLE" .or. cKey = "NAME" .or. cKey = "MODE"
  1927.               cResult = ""
  1928.               nX = nX + 2
  1929.               do while val(&aTmpArray[nX]) <> 0
  1930.                  do case
  1931.                     case cKey = "HANDLE" .and. upper(cKeyWord2) $ &aTmpArray[nX]
  1932.                          cResult = str(val(&aTmpArray[nX]))
  1933.  
  1934.                     case cKey = "NAME" .and. cKeyWord2 = val(&aTmpArray[nX])
  1935.                          cResult = substr(&aTmpArray[nX],10,40)
  1936.  
  1937.                     case cKey = "MODE" .and. cKeyWord2 = val(&aTmpArray[nX])
  1938.                          cResult = substr(&aTmpArray[nX],50,5)
  1939.                   endcase
  1940.                   if "" <> cResult
  1941.                      exit
  1942.                   endif
  1943.                   nX = nX + 1
  1944.               enddo
  1945.       endcase
  1946.    endif
  1947.  
  1948.    relase &aTmpArray
  1949.    nClose = fclose(nHandle)
  1950.    set safety off
  1951.    erase (cTempTxt)
  1952.    set safety &cSafety
  1953.    cResult = ltrim(rtrim(cResult))
  1954.  
  1955. RETURN iif(right(cResult,1) = ":",;
  1956.           left(cResult,len(cResult-1)),cResult)
  1957. *-- EoF: GetInfo()
  1958.  
  1959. FUNCTION TextLine
  1960. *-------------------------------------------------------------------------------
  1961. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1962. *-- Date........: 04/xx/1992
  1963. *-- Notes.......: Returns the number of lines of text in an ASCII Text File
  1964. *--               Taken from TechNotes, April, 1992
  1965. *-- Written for.: dBASE IV, 1.5
  1966. *-- Rev. History: None
  1967. *-- Calls.......: None
  1968. *-- Called by...: Any
  1969. *-- Usage.......: TextLine(<cTextFile>)
  1970. *-- Example.....: ?TextLine("CONFIG.DB")
  1971. *-- Returns.....: Number of lines
  1972. *-- Parameters..: cTextFile = name of file
  1973. *-------------------------------------------------------------------------------
  1974.  
  1975.    parameter cTextFile
  1976.    private nLines, nHandle, cTemp, nClose
  1977.  
  1978.    nLines = 0
  1979.    if file(cTextFile)   && if it exists ...
  1980.       nHandle = fopen(cTextFile,"R")
  1981.       do while .not. feof(nHandle)
  1982.          cTemp = fgets(nHandle,254)
  1983.          nLines = nLines + 1
  1984.       enddo
  1985.       nClose = fclose(nHandle)
  1986.    endif
  1987.  
  1988. RETURN nLines
  1989. *-- EoF: TextLine()
  1990.  
  1991. FUNCTION TLine
  1992. *-------------------------------------------------------------------------------
  1993. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1994. *-- Date........: 04/xx/1992
  1995. *-- Notes.......: Returns a specific line in an ASCII Text File. This is similar
  1996. *--               to the way MLINE() works on a memo field. Taken from TechNotes
  1997. *--               April, 1992.
  1998. *-- Written for.: dBASE IV, 1.5
  1999. *-- Rev. History: None
  2000. *-- Calls.......: None
  2001. *-- Called by...: Any
  2002. *-- Usage.......: TLine(<cTextFile>,<nLine>)
  2003. *-- Example.....: ?TLine("CONFIG.DB",20)
  2004. *-- Returns.....: Character expression - specified line of text file.
  2005. *-- Parameters..: cTextFile = name of text file
  2006. *--               nLine     = line to return from text file
  2007. *-------------------------------------------------------------------------------
  2008.  
  2009.    parameters cTextFile, nLine
  2010.    private cText, nX, nHandle, nClose
  2011.  
  2012.    cText = ""
  2013.    nX = 1
  2014.    if file(cTextFile)    && if file exists ...
  2015.       nHandle = fopen(cTextFile,"R")
  2016.       do while .not. feof(nHandle)
  2017.          cText = fgets(nHandle,254)
  2018.          if nX = nLine
  2019.             exit
  2020.          endif
  2021.          nX = nX + 1
  2022.       enddo
  2023.       nClose = fclose(nHandle)
  2024.    endif
  2025.  
  2026. RETURN cText
  2027. *-- EoF: TLine()
  2028.  
  2029. FUNCTION TLineNo
  2030. *-------------------------------------------------------------------------------
  2031. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2032. *-- Date........: 04/xx/1992
  2033. *-- Notes.......: Returns the line number of the phrase you are searching for
  2034. *--               in an ASCII Text File. This is similar to dBASE's AT() 
  2035. *--               function, but works on LINES rather than CHARACTERS.
  2036. *--               Taken from TechNotes, April, 1992
  2037. *-- Written for.: dBASE IV, 1.5
  2038. *-- Rev. History: None
  2039. *-- Calls.......: None
  2040. *-- Called by...: Any
  2041. *-- Usage.......: TLineNo(<cTextFile>,<cLookup>,[<lCase>])
  2042. *-- Example.....: ?TLineNo("CONFIG.DB","command",.f.)
  2043. *-- Returns.....: numeric value (the line number containing the line needed)
  2044. *--               returns -1 if not found
  2045. *-- Parameters..: cTextFile = Name of ASCII Text File
  2046. *--               cLookup   = Text to search for ...
  2047. *--               lCase     = Case Sensitive? (Default is .F.)
  2048. *-------------------------------------------------------------------------------
  2049.  
  2050.    parameters cTextFile, cLookup, lCase
  2051.    private cPhrase, nHandle, cText, nX, nClose
  2052.  
  2053.    if pCount() = 3 .and. lCase
  2054.       lCase = .t.
  2055.       cPhrase = cLookup
  2056.    else
  2057.       lCase = .f.
  2058.       cPhrase = upper(cLookup)
  2059.    endif
  2060.  
  2061.    cText = ""
  2062.    nX = 1
  2063.    if file(cTextFile)
  2064.       nHandle = fopen(cTextFile,"R")
  2065.       do while .not. feof(nHandle)
  2066.          cText = fgets(nHandle,254)
  2067.          if at(cPhrase,iif(lCase,cText,upper(cText))) > 0
  2068.             nClose = fclose(nHandle)
  2069.             RETURN nX
  2070.          endif
  2071.          nX = nX + 1
  2072.       enddo
  2073.  
  2074.       nClose = fclose(nHandle)
  2075.    endif
  2076.  
  2077. RETURN -1
  2078. *-- EoF: TLineNo()
  2079.  
  2080. FUNCTION TempFile
  2081. *-------------------------------------------------------------------------------
  2082. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2083. *-- Date........: 04/xx/1992
  2084. *-- Notes.......: Returns a random filename.
  2085. *-- Written for.: dBASE IV, 1.5
  2086. *-- Rev. History: None
  2087. *-- Calls.......: TempDir()            Function in LOWLEVEL.PRG
  2088. *-- Called by...: Any
  2089. *-- Usage.......: TempFile([cFileExt])
  2090. *-- Example.....: cVarFile = TempFile("$XY")
  2091. *-- Returns.....: Filename
  2092. *-- Parameters..: cFileExt = optional parameter - allows you to assign a
  2093. *--                          file extension to the end of the filename.
  2094. *-------------------------------------------------------------------------------
  2095.  
  2096.    parameters cFileExt
  2097.  
  2098. RETURN TempDir()+"TMP"+right(ltrim(str(rand(-1)*10000000)),5);
  2099.        +iif(pcount() = 0 .or. "" = cFileExt,"","."+cFileExt)
  2100. *-- EoF: TempFile()
  2101.  
  2102. FUNCTION TempDir
  2103. *-------------------------------------------------------------------------------
  2104. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2105. *-- Date........: 04/xx/1992
  2106. *-- Notes.......: Returns path of temporary directory as set from DOS
  2107. *--               (i.e., SET DBTMP= ...) Taken from TechNotes, April, 1992
  2108. *-- Written for.: dBASE IV, 1.5
  2109. *-- Rev. History: None
  2110. *-- Calls.......: GetEnv()             Function in LOWLEVEL.PRG
  2111. *-- Called by...: Any
  2112. *-- Usage.......: TempDir()
  2113. *-- Example.....: ?TempDir()
  2114. *-- Returns.....: Path of temporary directory
  2115. *-- Parameters..: None
  2116. *-------------------------------------------------------------------------------
  2117.  
  2118.   cTempDir = iif("" <> GetEnv("DBTMP"),GetEnv("DBTMP"),GetEnv("TMP"))
  2119.  
  2120. RETURN cTempDir+iif(right(cTempDir,1)<> "\" .and.;
  2121.          left(os(),3) = "DOS" .and. .not. "" = cTempDir,"\","")
  2122. *-- EoF: TempDir()
  2123.  
  2124. *-------------------------------------------------------------------------------
  2125. *-- EoP: FILES.PRG
  2126. *-------------------------------------------------------------------------------
  2127.